{***************************************************************************}
{                                                                           }
{           DUnitX                                                          }
{                                                                           }
{           Copyright (C) 2013 Vincent Parrett                              }
{                                                                           }
{           vincent@finalbuilder.com                                        }
{           http://www.finalbuilder.com                                     }
{                                                                           }
{                                                                           }
{***************************************************************************}
{                                                                           }
{  Licensed under the Apache License, Version 2.0 (the "License");          }
{  you may not use this file except in compliance with the License.         }
{  You may obtain a copy of the License at                                  }
{                                                                           }
{      http://www.apache.org/licenses/LICENSE-2.0                           }
{                                                                           }
{  Unless required by applicable law or agreed to in writing, software      }
{  distributed under the License is distributed on an "AS IS" BASIS,        }
{  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. }
{  See the License for the specific language governing permissions and      }
{  limitations under the License.                                           }
{                                                                           }
{***************************************************************************}

{***************************************************************************}
{                                                                           }
{               NOTICE of DERIVATION and CHANGE                             }
{                                                                           }
{  This file is a derived work. It is dervied from the DUnitX library       }
{  created By Vincent Parrett (hosted at https://github.com/VSoftTechnologies/DUnitX). }
{  The copyright holder for the originail code is as per the preceding      }
{  comment block. The copyright holder for all changes in this file from    }
{  that base is as denoted following.                                       }
{                                                                           }
{        Copyright (C) 2014 National Australia Bank Limited ACN 004 044 937 }
{                                                                           }
{        Author: Sean B. Durkin                                             }
{        sean@seanbdurkin.id.au                                             }
{***************************************************************************}

unit MLC.UnitTestFramework;
interface
uses SBD.Messages, SBD.Generics, Classes, SysUtils;

{$I ../includes/DUnitX.inc}


const
  // Message URL for framework messages:
  DUnixtX_Framework_URL    = 'https://github.com/VSoftTechnologies/DUnitX';
  DUnixtX_Framework_Prefix = 'dx';

  // Message codes for framework messages:
  UserIssuedWarning = 1;
  TestFailure       = 2;
  TestError         = 3;
  IgnoredTestCase   = 4;
  SetupError        = 5;
  TestException     = 6;
  NoChecks          = 7;
  LeakageFailure    = 8;
  TeardownError     = 9;
  SyntaxError       = 10;
  ResultAnnouncement = 11;
  ProgressAnnouncement = 12;
  UserAbort = 13;
  AbortOnFirstFail = 14;


type
TTestStatus = (
  tsNeutral,
  tsSetup,
  tsTeardown,
  tsExecuting,
  tsPass,
  tsWarn,
  tsFail,
  tsError,
  tsSkipped);




ITestProcedure = interface;
ITestCase = interface
  ['{4AC7C199-4E4E-4FF9-89B5-76C28A7E2D2D}']
    function  GetEnabled: boolean;
    procedure SetEnabled( Value: boolean);
    function  DisplayName: string;
    function  Parent: ITestProcedure;
    function  Load: integer;
    property  Enabled: Boolean read GetEnabled write SetEnabled;
  end;

ITestFixture = interface;
ITestProcedure = interface
  ['{A3AF569F-DEF8-49CE-A551-608D273D15EC}']
    function Name: string;
    function Parent: ITestFixture;
    function TestCases: ISEnumerable<ITestCase>;
    function Load: integer;
    function RepeatCount: integer;
    function Description: string;
    function GetDefaultEnabled: boolean;
    function IsIgnored( var IgnoreReason: string): boolean;
    function IgnoreLeaks: boolean;
  end;

ITestResult = interface;
ITestFixture = interface
  ['{F8BECF10-535D-4815-8759-E8854F640D44}']
    function Name: string;
    function Parent: ITestFixture;
    function FixtureChildren: ISEnumerable<ITestFixture>;
    function TestProcedures: ISEnumerable<ITestProcedure>;
    function Load: integer;
    function Description: string;
    function isNamespaceFixture: boolean;
  end;

RTimingStats = record
    FStart, FEnd: TDateTime;
    FDuration_ms: integer;  // Milliseconds of duration.
    procedure Clear;
  end;

TResultNodeKind = (rnRoot, rnNamespaceFixture, rnLeafFixture, rnTestProc, rnTestCase, rnTestCaseRound);
ITestSuite = interface
  ['{A870F6AD-54CF-48A2-B079-229C4C941095}']
    function Fixtures: ISEnumerable<ITestFixture>;
  end;


ITestResult = interface
  ['{8704A3FD-C908-4294-80A6-84F6775BF0E9}']
    function Status: TTestStatus;
    function RoundsCompleted: integer;
    function RoundsPerTestCase: integer;
    function ErrorCount: integer;
    function PassCount: integer;
    function FailCount: integer;
    function WarnCount: integer;
    function Timing: RTimingStats;
    function Messages: IMessageSource;
    function TestCase: ITestCase;
    function Fixture: ITestFixture;
    function ChildResults: ISEnumerable<ITestResult>;
    function Executed: boolean;
    function IgnoredCount: integer;
    function SkippedCount: integer;
    function NodeKind: TResultNodeKind;
    function ErrorOrFailureMsg( var FailMsg: RMessage): boolean;
    function NodeName: string;
  end;


TLoggerNode = (nFixture, nTestProc, nTestCase);

TSetFixtureDatumFunc = reference to procedure (const Addend: ITestFixture; const ViewDatum: IInterface);
TSetTestProcDatumFunc = reference to procedure (const Addend: ITestProcedure; const ViewDatum: IInterface);
TSetTestCaseDatumFunc = reference to procedure (const Addend: ITestCase; const ViewDatum: IInterface);

type
/// <remarks>
///  Loggers that log to a file, may depend on a IFilenameSource service.
/// </remarks>
IUnitTestingEngine = interface;
ITestLogger = interface
  ['{0BE3D866-6188-40EB-96BB-6F51BF086E07}']
    function  MenuDescription: string;
    procedure OnEnableChange( const Eng: IUnitTestingEngine; const Proc: ITestProcedure; const Datum: IInterface);
    procedure OnBeginRunInstance( Workload: integer);
    procedure OnEndRunInstance( const RunResult: ITestResult);
    procedure OnChangeStatus(
                        NodeKind: TLoggerNode;
                  const Fixture: ITestFixture;
                  const TestProc: ITestProcedure;
                  const TestCase: ITestCase;
                  const TestResult: ITestResult;
                  const Datum: IInterface);
    procedure OnAuxilaryMessage( const TestResult: ITestResult; const TestCase: ITestCase; const Msg: RMessage; const NodeDatum: IInterface);
    procedure Shutdown( const Eng: IUnitTestingEngine);
    procedure OnAttachSuite( Suite: ITestSuite;
             SetFixtureDatum: TSetFixtureDatumFunc;
             SetTestProcDatum: TSetTestProcDatumFunc;
             SetTestCaseDatum: TSetTestCaseDatumFunc);
    procedure OnProgressTick( const GrossResult: ITestResult; WorkDone, WorkLoad: integer);
    procedure Breathe;
  end;

IUnitTestingController = interface;
IUnitTestingEngine = interface
  ['{0420BDA2-583F-4A2D-85CF-1C586ECC13DB}']
    procedure RegisterFixtureClass( FixtureCls: TClass);
    function  Suite: ITestSuite;
    procedure Subscribe( const Observer: ITestLogger);
    procedure Unsubscribe( const Observer: ITestLogger);
    function  Run: ITestResult;
    procedure StartUp;
    procedure Shutdown;
    procedure Abort;
    procedure SetController( const Controller: IUnitTestingController);

    function  Can_Run: boolean;
    function  Can_Abort: boolean;
    function  IsRunning: boolean;
    function  GetBreakOnFirstFailure: boolean;
    procedure SetBreakOnFirstFailure( Value: boolean);

    property  BreakOnFirstFailure: boolean read GetBreakOnFirstFailure write SetBreakOnFirstFailure;
  end;

IUnitTestingController = interface
  ['{AE64C153-E5B0-412B-A414-9FEFE90799D2}']
    procedure UpdateActionStatii( const Eng: IUnitTestingEngine);
    function  CheckAbort: boolean;
  end;

IFilenameSource = interface
  ['{555499CC-460D-4FAA-96E5-CE9BE8209A6D}']
    function FileName: string;
  end;

IFilenameFactoryParameter = interface
  ['{C43C96B8-B35F-4615-BB96-007EA946EB5D}']
    function FileName: string;
    procedure SetFileName( const Value: string);
    function isValidFilename( const Value: string): boolean;
  end;

ILoggerFactory = interface
  ['{64122CBF-56B0-432B-B36A-58AA430E2C47}']
    function MenuDescription: string;
    function CreateLogger( const Params: IInterface): ITestLogger;
  end;

ILoggerFactoryUI = interface
  ['{9220819C-79F1-45E9-B8BD-98E8041FFA9C}']
    function  Factory: ILoggerFactory;
    function  EnquireForCreateLogger( out Params: IInterface): boolean;
    procedure ViewEditProperties( const Logger: ITestLogger; Params: IInterface);
  end;

IAdditionalLoggers = interface( ISEnumerable<ILoggerFactoryUI>)
  ['{F7542D70-C258-445D-BA6B-D61868760D51}']
  end;

TDUnitXAttributeBase = class( TCustomAttribute)
  end;


TTestMethod = procedure of object;
TTestLocalMethod = reference to procedure;
IAssert = interface
  ['{23BD3BBE-257D-4AFE-ADF7-15B21BB181E8}']
    procedure Pass;
    procedure Fail( const message : string = ''; const errorAddrs : pointer = nil);
    procedure Warn( const message : string = '');

    procedure AreEqual(const left : string; const right : string; const ignoreCase : boolean; const message : string);overload;
    procedure AreEqual(const left : string; const right : string; const message : string = '');overload;
    procedure AreEqual(const left, right : Extended; const tolerance : Extended; const message : string = '');overload;
    procedure AreEqual(const left, right : Extended; const message : string = '');overload;
    procedure AreEqual(const left, right : TClass; const message : string = '');overload;
    {$IFDEF DELPHI_XE_UP}
      //Delphi 2010 compiler bug breaks this
      class procedure AreEqual<T>(const left, right : T; const message : string = '');overload;
    {$ENDIF}
    procedure AreEqual(const left, right : Integer; const message : string = '');overload;

    procedure AreEqualMemory(const left : Pointer; const right : Pointer; const size : Cardinal; message : string = '');

    procedure AreNotEqual(const left : string; const right : string; const ignoreCase : boolean = true; const message : string = '');overload;
    procedure AreNotEqual(const left, right : Extended; const tolerance : Extended; const message : string = '');overload;
    procedure AreNotEqual(const left, right : TClass; const message : string = '');overload;
    {$IFDEF DELPHI_XE_UP}
      //Delphi 2010 compiler bug breaks this
      procedure AreNotEqual<T>(const left, right : T; const message : string = '');overload;
    {$ELSE}
      procedure AreNotEqual(const left, right : Integer; const message : string = '');overload;
    {$ENDIF}
    procedure AreNotEqualMemory(const left : Pointer; const right : Pointer; const size : Cardinal; message : string = '');

    procedure AreSame(const left, right : TObject; const message : string = '');overload;
    procedure AreSame(const left, right : IInterface; const message : string = '');overload;

    procedure AreNotSame(const left, right : TObject; const message : string = '');overload;
    procedure AreNotSame(const left, right : IInterface; const message : string = '');overload;

    {$IFDEF DELPHI_XE_UP}
    //Delphi 2010 compiler bug breaks this
      procedure Contains<T>(const list : IEnumerable<T>; const value : T; const message : string = '');overload;
      procedure DoesNotContain<T>(const list : IEnumerable<T>; const value : T; const message : string = '');overload;
    {$ENDIF}

    procedure IsTrue ( const condition : boolean; const message : string = '');
    procedure IsFalse( const condition : boolean; const message : string = '');

    procedure IsNull(const condition : TObject; const message : string = '');overload;
    procedure IsNull(const condition : Pointer; const message : string = '');overload;
    procedure IsNull(const condition : IInterface; const message : string = '');overload;
    procedure IsNull(const condition : Variant; const message : string = '');overload;

    procedure IsNotNull(const condition : TObject; const message : string = '');overload;
    procedure IsNotNull(const condition : Pointer; const message : string = '');overload;
    procedure IsNotNull(const condition : IInterface; const message : string = '');overload;
    procedure IsNotNull(const condition : Variant; const message : string = '');overload;

    procedure IsEmpty(const value : string; const message : string = '');overload;
    procedure IsEmpty(const value : Variant; const message : string = '');overload;
    procedure IsEmpty(const value : TStrings; const message : string = '');overload;
    procedure IsEmpty(const value : TList; const message : string = '');overload;
    procedure IsEmpty(const value : IInterfaceList; const message : string = '');overload;
    {$IFDEF DELPHI_XE_UP}
      //Delphi 2010 compiler bug breaks this
      procedure IsEmpty<T>(const value : IEnumerable<T>; const message : string = '');overload;
    {$ENDIF}

    procedure IsNotEmpty(const value : string; const message : string = '');overload;
    procedure IsNotEmpty(const value : Variant; const message : string = '');overload;
    procedure IsNotEmpty(const value : TStrings; const message : string = '');overload;
    procedure IsNotEmpty(const value : TList; const message : string = '');overload;
    procedure IsNotEmpty(const value : IInterfaceList; const message : string = '');overload;
    {$IFDEF DELPHI_XE_UP}
      //Delphi 2010 compiler bug breaks this
      procedure IsNotEmpty<T>(const value : IEnumerable<T>; const message : string = '');overload;
    {$ENDIF}

    procedure WillRaise(const AMethod : TTestLocalMethod; const exceptionClass : ExceptClass = nil; const msg : string = ''); overload;
    procedure WillRaise(const AMethod : TTestMethod; const exceptionClass : ExceptClass = nil; const msg : string = ''); overload;
    procedure WillNotRaise(const AMethod : TTestLocalMethod; const exceptionClass : ExceptClass = nil; const msg : string = ''); overload;
    procedure WillNotRaise(const AMethod : TTestMethod; const exceptionClass : ExceptClass = nil; const msg : string = ''); overload;

    procedure Contains(const theString : string; const subString : string; const ignoreCase : boolean = true; const message : string = '');overload;
    procedure StartsWith(const theString : string; const subString : string;const ignoreCase : boolean = true; const message : string = '');
    procedure EndsWith(const theString : string; const subString : string;const ignoreCase : boolean = true; const message : string = '');
    procedure InheritsFrom(const descendant : TClass; const parent : TClass; const message : string = '');
    {$IFDEF DELPHI_XE_UP}
      //Delphi 2010 compiler bug breaks this
      procedure IsType<T>(const value : T; const message : string = '');overload;
    {$ENDIF}

    {$IFDEF SUPPORTS_REGEX}
      procedure IsMatch(const regexPattern : string; const theString : string; const message : string = '');
    {$ENDIF}
  end;

TestFixtureAttribute = class abstract( TDUnitXAttributeBase)
  public
    FPathedName: string;
    constructor Create( const PathedName: string);
  end;
// A test fixture class MUST also have a protected datamember of type Assert: IAssert

TestAttribute = class( TDUnitXAttributeBase)
  public
    FEnabled: boolean;
    constructor Create( Enabled: boolean);    overload;
    constructor Create                   ;    overload;
  end;

IDataDrivenTestCaseCursor = interface
  ['{BA4BC7AF-5F4F-4875-A6CB-CC1D0E4FB374}']
     function  PrerunLoadEstimate: integer;
     function  Next: boolean;
     procedure TestLineItem( TestBed: TObject);
     function  LineItemDescription: string;
     function  RefCount: integer;     // For debug purposes. Remove soon.
   end;

TDataDrivenTestCaseCursor = class( TInterfacedObject, IDataDrivenTestCaseCursor)
  protected
     function  PrerunLoadEstimate: integer;       virtual;
     function  Next: boolean;                     virtual; abstract;
     procedure TestLineItem( TestBed: TObject);   virtual; abstract;
     function  LineItemDescription: string;       virtual;
     function  RefCount: integer;        // For debug purposes. Remove soon.
   end;

DataDrivenTestAttribute = class( TDUnitXAttributeBase)
  // Applies to method with signature ...
  //   function ~: IDataDrivenTestCaseCursor;
  public
    constructor Create;
  end;


TestCaseAttribute = class( TDUnitXAttributeBase)
  public
    FName: string;
    FData: string;
    constructor Create( const Name, Data: string);
  end;


DescriptionAttribute = class( TDUnitXAttributeBase)
  public
    FText: string;
    constructor Create( const Text: string);
  end;


IgnoreAttribute = class( TDUnitXAttributeBase)
  public
    FReason: string;
    constructor Create( const Reason: string);
  end;


RepeatsAttribute = class( TDUnitXAttributeBase)
  public
    FCount: integer;
    constructor Create( Count: integer);
  end;


IgnoreMemoryLeaksAttribute = class( TDUnitXAttributeBase)
  end;

SetupAttribute = class( TDUnitXAttributeBase)
  end;

TearDownAttribute = class( TDUnitXAttributeBase)
  end;

FixtureSetupAttribute = class( TDUnitXAttributeBase)
  end;
// Decorates a constructor.

TDataLoopDriver = reference to procedure ( TestBed: TObject; var More: boolean);

implementation




{ TestFixture }

constructor TestFixtureAttribute.Create( const PathedName: string);
begin
FPathedName := PathedName
end;

{ TestAttribute }

constructor TestAttribute.Create( Enabled: boolean);
begin
FEnabled := Enabled
end;

constructor TestAttribute.Create;
begin
Create( True)
end;

{ DataDrivenTestAttribute }

constructor DataDrivenTestAttribute.Create;
begin
end;

{ TestCaseAttribute }

constructor TestCaseAttribute.Create( const Name, Data: string);
begin
FName := Name;
FData := Data
end;

{ DescriptionAttribute }

constructor DescriptionAttribute.Create( const Text: string);
begin
FText := Text
end;

{ IgnoreAttribute }

constructor IgnoreAttribute.Create( const Reason: string);
begin
FReason := Reason
end;

{ RepeatsAttribute }

constructor RepeatsAttribute.Create( Count: integer);
begin
FCount := Count
end;



{ TDataDrivenTestCaseCursor }

function TDataDrivenTestCaseCursor.LineItemDescription: string;
begin
result := ''
end;

function TDataDrivenTestCaseCursor.PrerunLoadEstimate: integer;
begin
result := 1
end;

function TDataDrivenTestCaseCursor.RefCount: integer;
begin
result := self.FRefCount
end;

{ RTimingStats }

procedure RTimingStats.Clear;
begin
end;

end.
